(FILECREATED "10-Nov-78 20:18:53" <LENAT>UF.;2 4052   

     changes to:  CODE PARENTS LIST-IF-NONNULL UFFNS

     previous date: "10-Nov-78 17:22:12" <MOLGEN>UF.;2)


(PRETTYCOMPRINT UFCOMS)

(RPAQQ UFCOMS [(FNS * UFFNS)
	       (P (CHANGE-FAULTEVAL)
		  (CHANGE-FAULTAPPLY))
	       (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA NEW-FAULTEVAL)
										     (NLAML])

(RPAQQ UFFNS (NEW-FAULTAPPLY NEW-FAULTEVAL CHANGE-FAULTAPPLY CHANGE-FAULTEVAL CODEBACK CODE PARENTS LIST-IF-NONNULL))
(DEFINEQ

(NEW-FAULTAPPLY
  [LAMBDA (FAULTFN FAULTARGS)

          (* Allows one to type (APPLY* s u) in place of (GETVALUE s u), and to type (APPLY* s u f) in place of 
	  (GETVALUE f s u); also works for APPLY)


    (SELECTQ (FLENGTH FAULTARGS)
	     (1 UA.ERRNO←NIL
		(if FAULTFN='CLISP:
		    then (ORIG-FAULTAPPLY FAULTFN FAULTARGS)
		  elseif (GETFIELD 'VALUE FAULTFN FAULTARGS:1)
		  elseif UA.ERRNO=NIL
		    then NIL
		  elseif (AND (ANCESTOR? FAULTFN (QUOTE VSLOT))
			      (CODE FAULTFN)
			      (GETD FAULTFN))
		    then (APPLY FAULTFN FAULTARGS)
		  else (ORIG-FAULTAPPLY FAULTFN FAULTARGS)))
	     (2 UA.ERRNO←NIL
		(if FAULTFN='CLISP:
		    then (ORIG-FAULTAPPLY FAULTFN FAULTARGS)
		  elseif (GETFIELD FAULTARGS:2 FAULTFN FAULTARGS:1)
		  elseif UA.ERRNO=NIL
		    then NIL
		  elseif (AND (ANCESTOR? FAULTFN (QUOTE VSLOT))
			      (CODE FAULTFN)
			      (GETD FAULTFN))
		    then (APPLY FAULTFN FAULTARGS)
		  else (ORIG-FAULTAPPLY FAULTFN FAULTARGS)))
	     (ORIG-FAULTAPPLY FAULTFN FAULTARGS])

(NEW-FAULTEVAL
  [NLAMBDA FAULTX

          (* Allows one to type (CREATOR u) in place of (GETVALUE (QUOTE CREATOR) u), and to type 
	  (CREATOR u f) in place of (GETFIELD f (QUOTE CREATOR) u))


    (SELECTQ (LENGTH FAULTX)
	     (2 UA.ERRNO←NIL
		(if FAULTX:1='CLISP:
		    then (APPLY 'ORIG-FAULTEVAL FAULTX)
		  elseif (GETFIELD 'VALUE FAULTX:1 (EVAL FAULTX:2))
		  elseif UA.ERRNO=NIL
		    then NIL
		  elseif (AND (ANCESTOR? FAULTX:1 (QUOTE VSLOT))
			      (CODE FAULTX:1)
			      (GETD FAULTX:1))
		    then (EVAL FAULTX)
		  else (APPLY 'ORIG-FAULTEVAL FAULTX)))
	     (3 UA.ERRNO←NIL
		(if FAULTX:1='CLISP:
		    then (APPLY 'ORIG-FAULTEVAL FAULTX)
		  elseif (GETFIELD (EVAL FAULTX:3)
				   FAULTX:1
				   (EVAL FAULTX:2))
		  elseif UA.ERRNO=NIL
		    then NIL
		  elseif (AND (ANCESTOR? FAULTX:1 (QUOTE VSLOT))
			      (CODE FAULTX:1)
			      (GETD FAULTX:1))
		    then (EVAL FAULTX)
		  else (APPLY 'ORIG-FAULTEVAL FAULTX)))
	     (APPLY 'ORIG-FAULTEVAL FAULTX])

(CHANGE-FAULTAPPLY
  [LAMBDA NIL
    (if }(GETD 'ORIG-FAULTAPPLY)
	then (PUTD 'ORIG-FAULTAPPLY (GETD 'FAULTAPPLY)))
    (PUTD 'FAULTAPPLY (GETD 'NEW-FAULTAPPLY])

(CHANGE-FAULTEVAL
  [LAMBDA NIL
    (if }(GETD 'ORIG-FAULTEVAL)
	then (PUTD 'ORIG-FAULTEVAL (GETD 'FAULTEVAL)))
    (PUTD 'FAULTEVAL (GETD 'NEW-FAULTEVAL])

(CODEBACK
  [LAMBDA (UNIT)
    (CLISP: FAST)

          (* This takes the type of combiner (STYPE) and the arguments out of which the new virtual slot is to be built 
	  (BUILT-FROM), and applies the former to the latter)


    (DEFINE <UNIT ! (OR (NLSETQ (APPLY (STYPE UNIT)
				       (GET-LIST 'BUILT-FROM UNIT)))
			(ERROR!)) >)
    (PUTVALUE 'CODE UNIT UNIT)
    (CLASSIFY UNIT 'LISP])

(CODE
  [LAMBDA (UNIT)
    (CLISP: FAST)

          (* This takes the type of combiner (STYPE) and the arguments out of which the new virtual slot is to be built 
	  (BUILT-FROM), and applies the former to the latter)


    (DEFINE <<UNIT ! (OR (NLSETQ (APPLY (STYPE UNIT)
					(GET-LIST 'BUILT-FROM UNIT)))
			 (ERROR!)) >>)
    (PUTVALUE 'CODE UNIT UNIT)
    (CLASSIFY UNIT 'LISP])

(PARENTS
  [LAMBDA (UNIT)
    (LIST-IF-NONNULL (PARENT UNIT])

(LIST-IF-NONNULL
  [LAMBDA (X)
    (AND X <X>])
)
(CHANGE-FAULTEVAL)
(CHANGE-FAULTAPPLY)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA NEW-FAULTEVAL)

(ADDTOVAR NLAML )
)
(DECLARE: DONTCOPY
  (FILEMAP (NIL (536 3866 (NEW-FAULTAPPLY 548 . 1587) (NEW-FAULTEVAL 1591 . 2606) (CHANGE-FAULTAPPLY 2610 . 2775) (CHANGE-FAULTEVAL
2779 . 2938) (CODEBACK 2942 . 3344) (CODE 3348 . 3743) (PARENTS 3747 . 3810) (LIST-IF-NONNULL 3814 . 3863)))))
STOP